COMMENT ⊗   VALID 00019 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00003 00002	initial declarations and global variables
C00005 00003	! facilities:   error messages,syntax explanations,error,abort1
C00011 00004	! parsing procedures
C00012 00005	! recover,frcver
C00015 00006	! Readcode,helprequest
C00021 00007	! symbol table: check,checktot,ensym,delsym,newsym,oldsym
C00028 00008	! symbol table: mk_pr, mk_rec, mk_sym, symtree routines
C00036 00009	! symbol table: gtframe,checkoff,arrydim
C00039 00010	! symbol table: nwr,dcdsym,unlink,linkfr,nwarec
C00044 00011	! symbol table: control,insertion
C00050 00012	! symbol table: killtree,killvar,reset
C00053 00013	! assignment instruction
C00055 00014	! tree operations:   afx_node,ufx_node,copycode,copy,copy_tree
C00061 00015	! arm interactions:  read_pos,readarm,frasg,arm_check
C00064 00016	! arm interactions:  fconstructproc
C00068 00017	! system facilities: editcode,renmcode,bailcode,qbailcode
C00075 00018	! parse procedures: other
C00078 00019	! main program
C00086 ENDMK
C⊗;
comment initial declarations and global variables;

DEFINE $MAINPR=TRUE ;
DEFINE #NOFUNCT=TRUE; COMMENT ELIMINATE FUNCTIONS IN THIS VERSION;
REQUIRE 300 STRING_PDL;REQUIRE 1000 SYSTEM_PDL;
REQUIRE 10000 STRING_SPACE;
REQUIRE "HEADER.SAI" SOURCE_FILE;

IFC #DEBUG THENC
	REQUIRE "PRINTX.HDR[AL,HE]" SOURCE_FILE;
	!	FOR PRINTING OUT RECORDS ;
	! BAIL BUG REQUIRES FOLLOWING DUMMY PROCEDURE;
	PROCEDURE BAIL_ANAMOLY;
	BEGIN PRINTX(3); RECPRN(F_WRLD);TBLKSUPPRESS(NULL);SETRPM(0,0); END;
ENDC

LABEL MAINL;			! used by abort procedures to go to the top level;


PRESET_WITH NULL,"SCALAR","VECTOR","ROT","TRANS","FRAME","MACRO","FUNCTION";
INTERNAL STRING ARRAY $DTYPE[0:7];


! facilities:   error messages,syntax explanations,error,abort1;

! INTERNAL INTEGER $HELP;					! used by error;

	! error messages for syntactic errors;

PRESET_WITH
	"--→ ; ",
	"--→ , ",
	"--→ . ",
	"--→ [ ",
	"--→ ] ",
	"--→ ( ",
	"--→ ) ",
	"--→ + ",
	"--→ * ",
	"--→ ALONG ",
	"--→ BY ",
	"--→ INTO ",
	"--→ REL ",
	"--→ ROT ",
	"--→ TO ",
	"--→ TRANS ",
	"--→ WRT ",
	"--→ XHAT or YHAT or ZHAT ",
	"--→ YARM or BARM ",
	"--→ YHAND or BHAND ",
	"--→ INPUT after ↑, ↓, ∨, ∧, <, >",
 	"--→ identifier ",
	"--→ number ",
	"--→ file name ",
        "--→ arithmetic operator ",
	"required ←--",
	"--→ error in explicit ",
	"vector ←--",
	"rotation ←--",
	"frame ←--",
	"--→ affix_type is wrong ←--",
	"--→ wrong identifier or wrong number ←--",
	"--→ unrecognized instruction ←--",
	"| ",
	"VECTOR required after DISTANCE",
	"--→ undeclared identifier ";
INTERNAL STRING ARRAY $SYNMSG[0:35];

	! error messages used for semantic errors;
	! the first messages cannot be moved in another position because they 
	  are referred to using the type of the variables(#SC,#VT,#RT,@TR,@FR);

PRESET_WITH
	" scalar not existent ",		
        " vector not existent ",	
	" rotation not existent ",
	" trans not existent ",
        " frame not existent ",	
	" is not scalar nor vector nor rotation ",
	" object not existent ",		
	" out of symbol table, delete some variables and try again",
	" cannot be moved ",
	" already defined symbol ",
	" dismatching of types ",
	" affixed frame ",
	" reading on arm required ",
	" instruction not executed",
	" is a POINTY defined variable or constant and cannot be changed";
INTERNAL STRING ARRAY $SEMSG[0:14];




INTERNAL simple procedure esc_I;
	$esc_I←true;


	! called after syntax error. If required gives explanation of the error;

INTERNAL PROCEDURE ERROR(STRING ERR1,ERR2(NULL));
	BEGIN
	STRING ANSWER;
	INTEGER I,J;
	I ← LENGTH($CLINR);
	J ← LENGTH($CLNE);
	PRINT($CLNE[1 TO J-I]&LF&$CLINR,CRLF);
	PRINT (ERR1,ERR2,CRLF);
ifc false thenc to temporarily destroy
	PRINT("    ",TOKEN,"     ",$CLINR,IFC #HELP THENC "(? for more explanation)"
			ELSEC CRLF ENDC);
	IFC #HELP THENC 
		ANSWER←INCHRW;IF ANSWER=CR THEN INCHRW;
		OUTSTR(CRLF);
		IF ANSWER="?" THEN HLPMSG($HELP);	! if required gives explanations;
	ENDC
endc	IFC #DISPL THENC
		IF DEVICE≠DSK_X THEN $ALLOW←0;	! while reading display is not updated;
	ENDC
	ESC_P;
	LODED($CLNE&CR);		! so it is possible to correct the command;
	$CLINR←NULL; STOKEN←FALSE;
	GO TO MAINL;			! goes to the main loop;
	END;


	! called after unrecoverable semantic error;

INTERNAL PROCEDURE ABORT1(STRING NAME,ERROR(NULL));
	BEGIN
	PRINT (NAME,ERROR,CRLF);
	IFC #DISPL THENC
		IF DEVICE≠DSK_X THEN $ALLOW←0;	! while reading display is not updated;
	ENDC
! ***	PRINT("* ");ESC_P;
	LODED($CLNE&CR);		! so it is possible to correct the command;
	$CLINR←NULL; STOKEN←FALSE;
	GO TO MAINL;			! goes to the main loop;
	END;

INTERNAL PROCEDURE CHKESC_I;
	IF $ESC_I THEN
		BEGIN
		MTYDEVSTACK;
		PRINT("
<ESCAPE> I termination
");
		$ESC_I←FALSE;	ENABLE(15);	! reset it again;
		$ELFABORTED←TRUE;
		GOTO MAINL;
		END;
! parsing procedures;


	! saves important parts of last instruction, for default instructions.
	  Oldobj is used to pass to gettoken the value corresponding to the ⊗;

INTERNAL PROCEDURE OLDSAV(STRING CMD,OBJ);
	BEGIN
	OLDCMD←CMD;
	OLDOBJ←OBJ;
	END;
! recover,frcver;

	! called when an indefined variable is used. Tries to recover, asking
	  the correct name of the variable, and returns it.
	  (null string or <control-C> to return to the main loop);


STRING PROCEDURE RECOVER(STRING SYMB);
BEGIN "R"
STRING ANSWER;LABEL CC;
	! you can change the identifier symb;
CC:
LODED(SYMB&CR);
ANSWER←INCHWL;				! reads new identifier;
IFC #OUTPT THENC
	IF $OUT THEN CPRINT($TTYCH,ANSWER,CRLF);
ENDC
SYMB←SCAN(ANSWER,$ERRTAB,$BRCHR);	! eliminates blanks and checks break;
IF $BRCHR≠0 AND $BRCHR≠'40
   THEN BEGIN
	PRINT("break character found. Try again ");
        GO TO CC;			! so... you can try again;
    	END
   ELSE IF SYMB THEN RETURN(SYMB);	! a "good" symbol is returned;
	! you want to delete the instruction being interpreted;
CLRBUF;
	IFC #DISPL THENC
		IF DEVICE≠DSK_X THEN $ALLOW←0;	! while reading display is not updated;
	ENDC
PRINT($SEMSG[13],CRLF,"* ");
ESC_P;
GO TO MAINL;				! goes to the main loop;
END "R";


IFC #OUTPT THENC

	! allows recovering if a file not available has been required
	  (null string or <control-C> to return to the main loop);

INTERNAL STRING PROCEDURE FRCVER(STRING FILE);
	BEGIN "F"
	LODED(FILE&CR); 
	ASKUSER;
	IFC #OUTPT THENC
		IF $OUT THEN CPRINT($TTYCH,$CLINR,CRLF);
	ENDC
	IF $CLINR
	   THEN RETURN(NAMEFILE)                
	   ELSE BEGIN
		CLRBUF;
		IFC #DISPL THENC
 			IF DEVICE≠DSK_X THEN $ALLOW←0;	! while reading display is not updated;
		ENDC
		PRINT($SEMSG[13],CRLF,"* ");
		ESC_P;
		GO TO MAINL;			! goes to the main loop;
		END;
	END "F";
ENDC						  
! Readcode,helprequest;

IFC #OUTPT THENC

	! these procedures used to read from a file are here and not in 
	  the input/output module becuase the READEXEC procedure calls
	   the PARSE procedure  for each instruction;

	! the above comment is no longer true, since READEXEC no longer
	  exists.  However, they should be shifted to the input/output module
	  when some rational means to keep track of I/0 is settled upon.
	  I think what is wanted is a file record that it used to keep
	  all the information related to each file ;

INTERNAL PROCEDURE READCODE(STRING FID; BOOLEAN ECHO(FALSE));
	BEGIN
	PUSHDEVSTACK;
	OPEN($INPCH←GETCHAN,"DSK",0,3,0,1000,$BRCHR,$EOF);
	LOOKUP($INPCH,FID,$EOF);
	WHILE $EOF
	     DO	BEGIN
		PRINT("enter failed");
		FID←FRCVER(FID);
		LOOKUP($INPCH,FID,$EOF);
		END;
	IFC #DISPL THENC $ALLOW←$ALLOW+1; IF ECHO THEN DPYFREE; $SCLST←NULL; ! to force update; ENDC
	DEVICE←DSK_X;

	NEWFILE←TRUE; FILEPRINT←ECHO;
 	END;

CLEANUP FCLOSE;

ELSEC
INTERNAL PROCEDURE UPDATE;;
ENDC

	! called after reading ?. Gives some information, erasing the display;

IFC #HELP THENC 
	INTERNAL PROCEDURE HELPREQUEST;
	BEGIN "H"
	IFC #DISPL THENC DPYFREE;ENDC
		! reads the comand after ?, if there is;
!	$TAIL←SCAN($LINE,$SCNTAB,$BRCHR);
!	HLPDO($TAIL);					! in HELP.SAI[1,MLG];
	hlpmsg($help);
	ASKUSER;
	HLPDO($clinr);
	$clinr←$clne←null;
	IFC #DISPL THENC UPDATE;ENDC
	END "H";
ELSEC
INTERNAL PROCEDURE HELPREQUEST;;
ENDC

! symbol table: check,checktot,ensym,delsym,newsym,oldsym;
	! checks if symbol symb, of type nm, is in symbol table in the class nm,
	  and return its pointer;

INTERNAL RPTR(SYMBOL) PROCEDURE CHECK(STRING SYMB;INTEGER NM);
	BEGIN
	RPTR(SYMBOL) TEMP;INTEGER IND,I;
	IND←$ENTRY[NM];		! address of last record of type nm filled;
	FOR I← 1 STEP 1 UNTIL IND DO
	    IF (TEMP←$YMTAB[NM,I])≠NULL_RECORD AND EQU(SYMBOL:PNAME[TEMP],SYMB) 
		       THEN RETURN(TEMP);
	RETURN(NULL_RECORD);			! symbol not found;
	END;

 	! checks if symbol symb is in symbol table, determines its class and
	  return its pointer;

INTERNAL RPTR(SYMBOL) PROCEDURE CHECKTOT(STRING SYMB);
	BEGIN
	INTEGER K;RPTR(SYMBOL)TEMP;
	FOR K←#MIN STEP 1 UNTIL #MAX DO
	    IF (TEMP←CHECK(SYMB,K))≠NULL_RECORD 
	       THEN RETURN(TEMP);
	RETURN(NULL_RECORD);			! symbol not found;
	END;


	! enters the symbol symb and the pointer to its node in symbol table,
	  in the class nm. The record of the class SCALAR,VECTOR,ROT,TRANS or
	  FRAME has to be constructed before calling ENSYM;


INTEGER PROCEDURE NEW_OFFSET(INTEGER NM);
	BEGIN
	INTEGER I;
	IF NM≠#MC THEN
	IF OFFSET[CUR_OFFSET,NM]=OFFSET[MAX_OFFSET,NM] THEN ERROR("NO MORE SPACE FOR NEW SYMBOLS IN 11");
	IF #SC≤NM≤#VT OR #MC≤NM≤#PR
		THEN OFFSET[CUR_OFFSET,NM]←OFFSET[CUR_OFFSET,NM]+1
		ELSE FOR I← 3 STEP 1 UNTIL 5 DO OFFSET[CUR_OFFSET,I]←OFFSET[CUR_OFFSET,I]+1;
	RETURN(OFFSET[CUR_OFFSET,NM]);
	END;

INTERNAL RPTR(SYMBOL) PROCEDURE ENSYM(STRING SYMB;INTEGER NM;RANY VAL;
	RPTR(SYMBOL)OLDREC(NULL_RECORD); INTEGER ACCESS(#SIMPLE));
	BEGIN
	RPTR (SYMBOL) TEMP;INTEGER IND;
	IF $ENTRY[NM]≥#LTYPE 
	   THEN ABORT1($SEMSG[7]);	! out of symbol table;
	IF OLDREC THEN TEMP←OLDREC ELSE	TEMP←NEW_RECORD(SYMBOL);
	$YMTAB[NM,$ENTRY[NM]←$ENTRY[NM]+1]←TEMP; ! pointer to the new record in $YMTAB;
!		SYMBOL:VALID[TEMP]←TRUE;
	SYMBOL:TYPE[TEMP]←NM;
	SYMBOL:PNAME[TEMP]←SYMB;	! pname of symbol;
	SYMBOL:OBJECT[TEMP]←VAL;	! pointer to the record previously created;
	IF ACCESS=#SIMPLE AND #SC≤NM≤#FR THEN
		BEGIN  SYMBOL:INDEX[TEMP]←NEW_OFFSET(NM);
		       SYMBOL:OFFSET[TEMP]←ARROFF[NM];
		END
	ELSE IF NM=#MC THEN SYMBOL:INDEX[TEMP]←NEW_OFFSET(NM);
	RETURN(TEMP);
	END;


INTERNAL PROCEDURE ENSYM$(RPTR(SYMBOL)SYM; INTEGER NM(0));
	BEGIN
	INTEGER IND;
	IF NM=0 THEN NM←SYMBOL:TYPE[SYM]
		ELSE SYMBOL:TYPE[SYM]←NM;
	IF $ENTRY[NM]≥#LTYPE 
	   THEN ABORT1($SEMSG[7]);	! out of symbol table;
	$YMTAB[NM,$ENTRY[NM]←$ENTRY[NM]+1]←SYM;		! pointer to the new record in $YMTAB;
	IF SYMBOL:ACCESS[SYM]=#SIMPLE AND #SC≤NM≤#FR THEN
		BEGIN  SYMBOL:INDEX[SYM]←NEW_OFFSET(NM);
		       SYMBOL:OFFSET[SYM]←ARROFF[NM];
		END
	ELSE IF NM=#MC THEN SYMBOL:INDEX[SYM]←NEW_OFFSET(NM);
	END;

	! returns a new symbol, if symb is present in $YMTAB. Id used before 
	  inserting a new symbol in $YMTAB to be sure that a symbol with the 
	  name has not been defined before. This procedure allows recovering;

STRING PROCEDURE NEWSYM(STRING SYMB);
	BEGIN
	RPTR(SYMBOL)TEMP;
	! if there is a symbol with the same pname allows recovering;
	WHILE (TEMP←CHECKTOT(SYMB))≠NULL_RECORD 
	     DO BEGIN
	        PRINT(SYMB,$SEMSG[9]); 
		SYMB←RECOVER(SYMB);
		END;
	RETURN(SYMB);
	END;

	! checks if symb is present in $YMTAB and returns its pointer and its
	  type (using the reference variable obtype), otherwise allows recovering.
	  Is used when the symbol required has to be present in $YMTAB (ex. 
	  in EDIT or RENAME instruction);

INTERNAL RPTR(SYMBOL) PROCEDURE OLDSYM(REFERENCE STRING SYMB;REFERENCE INTEGER OBTYPE);
	BEGIN
	RPTR(SYMBOL)EL;
	EL←CHECKTOT(SYMB);
	! if symbol is not in $YMTAB, recovering is allowed;
	WHILE (EL←CHECKTOT(SYMB))=NULL_RECORD
	     DO BEGIN
		PRINT ($SEMSG[6]);
		SYMB←RECOVER(SYMB);
		END;
	OBTYPE←SYMBOL:TYPE[EL];
	RETURN(EL);
	END;


PROCEDURE DELSYM(RPTR(SYMBOL)EL);
	BEGIN
	INTEGER ADDRFN,I;
	INTEGER OBTYPE; OBTYPE←SYMBOL:TYPE[EL];
	ADDRFN← $ENTRY[OBTYPE];	! final addr. in $YMTAB for class;
	FOR I←1 STEP 1 UNTIL ADDRFN DO
	IF $YMTAB[OBTYPE,I]=EL 
	   THEN BEGIN
	 	$YMTAB[OBTYPE,I]←$YMTAB[OBTYPE,ADDRFN];
		$ENTRY[OBTYPE]←ADDRFN-1;	! move last element into hole;
!		SYMBOL:VALID[EL]←FALSE;
		DONE;
		END;
	END;

! symbol table: mk_pr, mk_rec, mk_sym, symtree routines;

	! produces a symbol record with certain fields filled in ;
INTERNAL RPTR(SYMBOL)PROCEDURE MK_SYM(STRING PNAME; INTEGER TYPE;
		RANY PTR(NULL_RECORD); INTEGER ACCESS(#SIMPLE));
	BEGIN
	RPTR(SYMBOL)SYM;
	SYM←NEW_RECORD(SYMBOL);
	SYMBOL:PNAME[SYM]←PNAME;
	SYMBOL:TYPE[SYM]←TYPE;
	SYMBOL:OBJECT[SYM]←PTR;
	SYMBOL:ACCESS[SYM]←ACCESS;
	RETURN(SYM);
	END;

INTERNAL RPTR(PROC)PROCEDURE MK_PR(INTEGER ARGS; STRING ARRAY ARGNAME;
			INTEGER ARRAY ARGTYPE,ARGACCS,ARGDIM);
IF ARGS=0 THEN RETURN(NEW_RECORD(PROC)) ELSE
	BEGIN
	RPTR(PROC)E;
	STRING ARRAY S[1:ARGS];
	INTEGER ARRAY T,C,D[1:ARGS];
	ARRTRAN(S,ARGNAME);
	ARRTRAN(T,ARGTYPE);
	ARRTRAN(C,ARGACCS);
	ARRTRAN(D,ARGDIM);
	E←NEW_RECORD(PROC);
	PROC:NARGS[E]←ARGS;
	MEMORY[LOCATION(PROC:ARGNAME[E])]↔MEMORY[LOCATION(S)];
	MEMORY[LOCATION(PROC:ARGDIM[E])]↔MEMORY[LOCATION(D)];
	MEMORY[LOCATION(PROC:ARGACCS[E])]↔MEMORY[LOCATION(C)];
	MEMORY[LOCATION(PROC:ARGTYPE[E])]↔MEMORY[LOCATION(T)];
	RETURN(E);
	END;
IFC NOT #NOFUNCT THENC
INTERNAL RPTR(FUNCTION) PROCEDURE MK_FN(INTEGER ARGS);
	BEGIN
	RPTR(SCALAR,VECTOR,ROT,TRANS,FRAME,FUNCTION) ARRAY P[0:ARGS];
	STRING ARRAY S[0:ARGS]; 	INTEGER ARRAY I[0:ARGS];
	RPTR(FUNCTION)F;		F←NEW_RECORD(FUNCTION);
	FUNCTION:NARGS[F]←ARGS;
		MEMORY[LOCATION(FUNCTION:ARGNAME[F])]←MEMORY[LOCATION(S)];
		MEMORY[LOCATION(FUNCTION:PTR[F])]←MEMORY[LOCATION(P)];
		MEMORY[LOCATION(FUNCTION:ARGTYPE[F])]←MEMORY[LOCATION(I)];
		MEMORY[LOCATION(I)]←
		MEMORY[LOCATION(P)]←MEMORY[LOCATION(S)]←0;
	RETURN(F);
	END;
ENDC
INTERNAL RPTR(SCALAR,VECTOR,ROT,TRANS,FRAME) PROCEDURE MK_REC(INTEGER TYPE);
	BEGIN
	RANY TEMP;
	REAL ARRAY XF[1:6];
	CASE TYPE OF 
	begin "case"
	[#SC] TEMP←NEW_RECORD(SCALAR);
	[#VT] TEMP←NEW_RECORD(VECTOR);
	[#RT] BEGIN
		TEMP←NEW_RECORD(ROT);
		MEMORY[LOCATION(ROT:XF[TEMP])]←MEMORY[LOCATION(XF)];
		END;
	[#TR] BEGIN
		TEMP←NEW_RECORD(TRANS);
		MEMORY[LOCATION(TRANS:XF[TEMP])]←MEMORY[LOCATION(XF)];
		END;
	[#FR] BEGIN
		TEMP←NEW_RECORD(FRAME);
		MEMORY[LOCATION(FRAME:XF[TEMP])]←MEMORY[LOCATION(XF)];
! insert here the affixment to the world;
		FRAME:HOWLINKED[TEMP]←#INDLK;		! independently;
		END;
!	[#MC]	TEMP←NEW_RECORD(MACRO);
	[#FN]	TEMP←NEW_RECORD(PROC);
	ELSE	ERROR("PARSER ERROR, NO SUCH RECORD CLASS IN MK_REC")
	end "case";
	MEMORY[LOCATION(XF)]←0;
	RETURN(TEMP);
	END;

RPTR(SYMTREE)PROCEDURE MK_SYMTREE(RPTR(SYMBOL)S);
	BEGIN
	RPTR(SYMTREE)E;
	SYMTREE:SYM[E←NEW_RECORD(SYMTREE)]←S;
	RETURN(E);
	END;

RECURSIVE PROCEDURE INSRTTREE(RPTR(SYMBOL)S; RPTR(SYMTREE)STREE);
	BEGIN
	RPTR(SYMTREE)SS;
	CASE COMPEQU(SYMBOL:PNAME[S],SYMBOL:PNAME[SYMTREE:SYM[STREE]])+1 OF
		BEGIN
		[-1+1]	IF (SS←SYMTREE:LLINK[STREE])=NULL_RECORD
				THEN SYMTREE:LLINK[STREE]←MK_SYMTREE(S)
				ELSE INSRTTREE(S,SS);
		[0+1]	ERROR("ugh trying to insert element ");
		[1+1]	IF (SS←SYMTREE:RLINK[STREE])=NULL_RECORD
				THEN SYMTREE:RLINK[STREE]←MK_SYMTREE(S)
				ELSE INSRTTREE(S,SS)
		END;
	END;

INTERNAL PROCEDURE INSERTSYMTREE(RPTR(SYMBOL)S;RPTR(BLOCKREC)STREE);
	BEGIN
	IF BLOCKREC:TREE[STREE]=NULL_RECORD
	  THEN BLOCKREC:TREE[STREE]←MK_SYMTREE(S)
	  ELSE INSRTTREE(S,BLOCKREC:TREE[STREE]);
	BLOCKREC:#ARGS[STREE]←BLOCKREC:#ARGS[STREE]+1;
	END;

INTERNAL RPTR(BLOCKREC)PROCEDURE BLOCKIFY(INTEGER NARGS; RPTR(SYMBOL)ARRAY SYMARR;
		RPTR(BLOCKREC)BLOCK(NULL_RECORD));
	BEGIN INTEGER I;
	RPTR(BLOCKREC)BLOCKPTR;
	IF BLOCK THEN BLOCKPTR←BLOCK ELSE BLOCKPTR←NEW_RECORD(BLOCKREC);
	FOR I←1 STEP 1 UNTIL NARGS DO
		INSERTSYMTREE(SYMARR[I],BLOCKPTR);
	RETURN(BLOCKPTR);
	END;

RPTR(SYMBOL)RECURSIVE PROCEDURE SEARCHSYMTREE(STRING S; RPTR(SYMTREE)STREE);
    IF STREE=NULL_RECORD
	THEN RETURN(NULL_RECORD)
	ELSE CASE COMPEQU(S,SYMBOL:PNAME[SYMTREE:SYM[STREE]]) +1 OF
		BEGIN
		[-1+1]	RETURN(SEARCHSYMTREE(S,SYMTREE:LLINK[STREE]));
		[0+1]	RETURN(SYMTREE:SYM[STREE]);
		[1+1]	RETURN(SEARCHSYMTREE(S,SYMTREE:RLINK[STREE]))
		END;

INTERNAL RPTR(SYMBOL)PROCEDURE SEARCHBLOCK(STRING S; RPTR(BLOCKREC)R);
	RETURN(SEARCHSYMTREE(S,BLOCKREC:TREE[R]));

RPTR(SYMBOL)RECURSIVE PROCEDURE SEARCHSYMTREEOFF(INTEGER I; RPTR(SYMTREE)STREE);
	IF STREE=NULL_RECORD
	    THEN RETURN(NULL_RECORD)
	    ELSE IF I=SYMBOL:OFFSET[SYMTREE:SYM[STREE]]
		THEN RETURN(SYMTREE:SYM[STREE])
		ELSE BEGIN
			RPTR(SYMBOL)S;
			IF S←SEARCHSYMTREEOFF(I,SYMTREE:LLINK[STREE])
			    THEN RETURN(S)
			    ELSE RETURN(SEARCHSYMTREEOFF(I,SYMTREE:RLINK[STREE]))
		     END;

RPTR(SYMBOL)PROCEDURE SEARCHBLOCKOFF(INTEGER I; RPTR(BLOCKREC)R);
	IF R THEN RETURN(SEARCHSYMTREEOFF(I,BLOCKREC:TREE[R]))
		ELSE RETURN(NULL_RECORD);
! symbol table: gtframe,checkoff,arrydim;

INTERNAL RPTR(FRAME) PROCEDURE GTFRAME(INTEGER LEVOFF,#DIM; INTEGER ARRAY DIM;
				RPTR(SYMBOL)S);
	IF LEVOFF=ARROFF[#FR] THEN
		BEGIN
		RPTR(SYMBOL)TEMP;
		INTEGER I;
		FOR I←1 STEP 1 UNTIL $ENTRY[#FR] DO
			IF DIM[1]=SYMBOL:INDEX[TEMP←$YMTAB[#FR,I]] THEN
				RETURN(SYMBOL:OBJECT[TEMP]);
		RETURN(NULL_RECORD);
		END
	ELSE BEGIN "array or temporary"
		! not quite reight, this only assumes arrays;
		RPTR(ARRAYREC)ARR;
		INTEGER I,J;
		IF NOT S THEN ERROR("ERROR n GTFRAME: cant handle temporary variables yyet");
		ARR←SYMBOL:OBJECT[S];
		J←0;
		FOR I←1 STEP 1 UNTIL #DIM
			DO J←J+(DIM[I]-ARRAYREC:LB[ARR][I])*ARRAYREC:MUL[ARR][I];
		RETURN(SYMBOL:OBJECT[ARRAYREC:PTR[ARR][J+1]]);
	     END "array or temporary";

	! returns the symbol for given offset;
RPTR(SYMBOL) PROCEDURE CHECKOFF(INTEGER LEVOFF);
	BEGIN
	RPTR(SYMBOL) TEMP; INTEGER I,J;
	IF CURBLOCK AND TEMP←SEARCHBLOCKOFF(LEVOFF,CURBLOCK) THEN RETURN(TEMP);
	FOR I←#SC STEP 1 UNTIL #FR DO
		FOR J←1 STEP 1 UNTIL $ENTRY[I]
		DO IF (TEMP←$YMTAB[I,J]) AND SYMBOL:OFFSET[TEMP]=LEVOFF
			THEN RETURN(TEMP);
	RETURN(NULL_RECORD);
	END;

	! returns number of dimensions in symbol table for the leveloffset given;
INTERNAL INTEGER PROCEDURE ARRYDIM(INTEGER LEVOFF;REFERENCE RPTR(SYMBOL) SYM);
	BEGIN
	SYM←NULL_RECORD;
	IF LEVOFF=ARROFF[#SC] OR LEVOFF=ARROFF[#VT] OR LEVOFF=ARROFF[#RT]
		OR LEVOFF=ARROFF[#TR] OR LEVOFF=ARROFF[#FR]
		THEN RETURN(1)
		ELSE IF SYM←CHECKOFF(LEVOFF)
			THEN IF SYMBOL:ACCESS[SYM]=#SIMPLE THEN RETURN(0)
			ELSE RETURN(ARRAYREC:#DIM[SYMBOL:OBJECT[SYM]])
		ELSE RETURN(0);
	END;

! symbol table: nwr,dcdsym,unlink,linkfr,nwarec;

PROCEDURE UNLINK(RPTR(FRAME) N);
	BEGIN
	RPTR(FRAME) Y,E;
 	E←FRAME:EBRO[N];
 	IF (Y←FRAME:YBRO[N])≠NULL_RECORD 
	   THEN FRAME:EBRO[Y]←E
	   ELSE IF FRAME:DAD[N]≠NULL_RECORD THEN FRAME:SON[FRAME:DAD[N]]←E;
	IF E≠NULL_RECORD THEN FRAME:YBRO[E]←Y;
 	FRAME:EBRO[N]←NULL_RECORD;
 	FRAME:YBRO[N]←NULL_RECORD;
 	FRAME:DAD[N]←NULL_RECORD;
	END;

BOOLEAN PROCEDURE IS_ANCESTOR(RPTR(FRAME) N,D);
	BEGIN
	WHILE N≠NULL_RECORD DO
		IF N=D	THEN RETURN(TRUE) 
			ELSE N←FRAME:DAD[N];
	RETURN(FALSE);
	END;

	! sets #UP pointer structure in frame tree for N to be a child of D;

INTERNAL PROCEDURE LINKFR(RPTR(FRAME) N,D);	
	BEGIN
	IF NOT(D=F_WRLD AND FRAME:HOWLINKED[N]=#INDLK) 
	   THEN IF IS_ANCESTOR(D,N)
 		   THEN ABORT1(" backwards affixment to",frame:pname[D]);
        IF FRAME:DAD[N]≠NULL_RECORD THEN UNLINK(N);
 	IF (FRAME:EBRO[N]←FRAME:SON[D])≠NULL_RECORD THEN
 		FRAME:YBRO[FRAME:EBRO[N]]←N;
 	FRAME:YBRO[N]←NULL_RECORD;
 	FRAME:DAD[N]←D;
 	FRAME:SON[D]←N;
	END;


INTERNAL RPTR(TRANS) PROCEDURE ABSLOC(RPTR(FRAME) ND);
	BEGIN
	PRINT("DUMMY ABSLOC"); RETURN(NULL_RECORD);	END;

RPTR(SYMBOL)PROCEDURE NWR(STRING SYMB; INTEGER TYP);
	BEGIN
	RPTR(SCALAR,VECTOR,ROT,TRANS,FRAME)VAL; RPTR(SYMBOL)TEMP;
	SYMB←NEWSYM(SYMB);
	VAL←MK_REC(TYP);
	TEMP←ENSYM(SYMB,TYP,VAL);
	IF TYP=#FR THEN BEGIN FRAME:PNAME[VAL]←SYMB;
			IF TEMP≠ WORLD THEN LINKFR(VAL,F_WRLD);
			FRAME:PNAME[VAL]←SYMB;
			FRAME:HOWLINKED[VAL]←#INDLK;
			FRAME:SYM[VAL]←TEMP;
			END;
	$DISPLAYLIST[TYP]←NULL;
	RETURN(TEMP);
	END;

	! like nwr but does not insert into symbol table;
INTERNAL RPTR(SYMBOL)PROCEDURE NNWR(STRING SYMB; INTEGER TYP; INTEGER ACCESS(0));
	BEGIN
	RPTR(SCALAR,VECTOR,ROT,TRANS,FRAME)VAL; RPTR(SYMBOL)TEMP;
	TEMP←MK_SYM(SYMB,TYP,VAL←MK_REC(TYP),ACCESS);
	IF TYP=#FR THEN BEGIN
			IF TEMP≠ WORLD THEN LINKFR(VAL,F_WRLD);
			FRAME:PNAME[VAL]←SYMB;
			FRAME:HOWLINKED[VAL]←#INDLK;
			FRAME:SYM[VAL]←TEMP;
			END;
	RETURN(TEMP);
	END;


INTERNAL RPTR(SYMBOL)PROCEDURE NWAREC(RPTR(SYMBOL)TEMP;INTEGER #EL;
		INTEGER ARRAY LB,UB,MULT);
	BEGIN
	RPTR(ARRAYREC)VAL;
	INTEGER TYP,#DIM;
	VAL←SYMBOL:OBJECT[TEMP];
	TYP←SYMBOL:TYPE[TEMP];
	#DIM←ARRAYREC:#DIM[VAL];
		BEGIN
		INTEGER ARRAY ALB,AUB,MUL[1:5];
		INTEGER ARRAY I[1:5];
		INTEGER J,JJ;
		STRING S1,S2;
		RPTR(SYMBOL) ARRAY PTR[1:#EL];
		ARRBLT(ALB[1],LB[1],#DIM);
		ARRBLT(AUB[1],UB[1],#DIM);
		ARRBLT(MUL[1],MULT[1],#DIM);
		S1←SYMBOL:PNAME[TEMP]&"[";
		JJ←0;
		FOR I[1]←LB[1] STEP 1 UNTIL UB[1] DO
		FOR I[2]←LB[2] STEP 1 UNTIL UB[2] DO
		FOR I[3]←LB[3] STEP 1 UNTIL UB[3] DO
		FOR I[4]←LB[4] STEP 1 UNTIL UB[4] DO
		FOR I[5]←LB[5] STEP 1 UNTIL UB[5] DO
			BEGIN
			S2←S1&CVS(I[1]);
			FOR J←2 STEP 1 UNTIL #DIM DO
				S2←S2&","&CVS(I[J]);
			S2←S2&"]";
			PTR[JJ←JJ+1]←NNWR(S2,TYP,#ARRAY_ELEMENT);
			END;
		ARRAYREC:#EL[VAL]←#EL;
		MEMORY[LOCATION(ARRAYREC:PTR[VAL])]↔MEMORY[LOCATION(PTR)];
		MEMORY[LOCATION(ARRAYREC:LB[VAL])]↔MEMORY[LOCATION(ALB)];
		MEMORY[LOCATION(ARRAYREC:UB[VAL])]↔MEMORY[LOCATION(AUB)];
		MEMORY[LOCATION(ARRAYREC:MUL[VAL])]↔MEMORY[LOCATION(MUL)];
		END;
	RETURN(TEMP);
	END;
! symbol table: control,insertion;

RPTR(SYMBOL)PROCEDURE CNVRTR(RPTR(SYMBOL)EL;STRING SYMB);
	BEGIN
	RPTR(TRANS) TEMP;
	TEMP←SYMBOL:OBJECT[EL];
	DELSYM(EL);
	EL←NWR(SYMB,#FR);
	ARRTRAN(FRAME:XF[SYMBOL:OBJECT[EL]],TRANS:XF[TEMP]);
	$FRLST←$TRLST←NULL;
	RETURN(EL);
	END;

	! if the symbol symb is present in $YMTAB in the class OBTYPE returns
	  the pointer to it, otherwise allows recovering. The symbol is passed 
	  by reference so after recovering the new symbol is sent back;

RPTR(SYMBOL) PROCEDURE BELONGS2(REFERENCE STRING SYMB;INTEGER OBTYPE);
	BEGIN
	RPTR(SYMBOL) EL;
	EL←CHECK(SYMB,OBTYPE);		! checks if symbol is present;
	WHILE EL=NULL_RECORD
	     DO BEGIN
		IF OBTYPE=#FR
		   THEN BEGIN
			EL←CHECK(SYMB,#TR);
			IF EL 
			   THEN BEGIN
				EL←CNVRTR(EL,SYMB);
				RETURN(EL);
				END;
			END;
		PRINT($SEMSG[OBTYPE-#MIN]);
		SYMB←RECOVER(SYMB);	! recover can interrupt the loop and abort;
		EL←CHECK(SYMB,OBTYPE);
		END;
	RETURN(EL);	! returns the pointer to the symbol;
	END;

INTERNAL RANY PROCEDURE BELONGS(REFERENCE STRING SYMB; INTEGER OBTYPE);
	RETURN(SYMBOL:OBJECT[BELONGS2(SYMB,OBTYPE)]);

	! checks if the symbol (scalar,vector or rotation) is in $YMTAB.
	  If not inserts it, and returns its pointer;	

FORWARD RPTR(FRAME) PROCEDURE FR_INSERT (REFERENCE STRING SYMB);
RPTR(SYMBOL) PROCEDURE INSERT(STRING SYMB;INTEGER OBTYPE);
	BEGIN
	RPTR(SYMBOL)EL;
	IF OBTYPE=#FR THEN
		BEGIN RPTR(FRAME)FR1; STRING S1;
			S1←SYMB;
			FR1←FR_INSERT(S1);
			RETURN(CHECK(S1,OBTYPE));
		END;
	EL←CHECK(SYMB,OBTYPE);
	IF EL=NULL_RECORD THEN EL←NWR(SYMB,OBTYPE);
	RETURN(EL);
	END;

	! returns the pointer to the frame. If the frame is not present inserts it,
	  otherwise checks its affixment type  and asks for a confirmation if
	  the affixment type is not independent. In that case recovering is allowed;

RPTR(FRAME) PROCEDURE FR_INSERT (REFERENCE STRING SYMB);
	BEGIN "A"
	RPTR(SYMBOL) EL;
	RPTR(FRAME) FRA; STRING TEMP;INTEGER LINK;
	WHILE TRUE 
	     DO	BEGIN "LOOP"
		EL←CHECK(SYMB,#FR);			! if while copying;
		IF $HELP=14 
		   THEN WHILE EL≠NULL_RECORD
			     DO	BEGIN
				! while copying a new frame is required.
				  Recovering is allowed if the frame is existent;
				PRINT($SEMSG[9]);
				SYMB←RECOVER(SYMB);	
				EL←CHECK(SYMB,#FR);
				END;
		IF EL=NULL_RECORD
		   THEN BEGIN
			EL←CHECK(SYMB,#TR);
			IF EL THEN EL←CNVRTR(EL,SYMB)
			   ELSE EL←NWR(SYMB,#FR);		! defines a new frame;
			   RETURN(SYMBOL:OBJECT[EL]);
			END
		   ELSE BEGIN "C"
			FRA←SYMBOL:OBJECT[EL];
			LINK←FRAME:HOWLINKED[FRA];
			! changing values of the frame is allowed if link is #INDLK;
			IF LINK=#INDLK
			   THEN	BEGIN
				$FRLST←NULL;
				RETURN(FRA);
				END
			   ELSE BEGIN
				! otherwise a confirmation is required;
				PRINT(SYMB,
" affixed frame. Changing values can modify the frame tree.",CRLF,
				"You can change the name ");
				TEMP←RECOVER(SYMB);
				! if the name of the frame is the same, 
				  changing values is allowed;
				IF EQU(TEMP ,SYMB) 
				   THEN BEGIN
					$FRLST←NULL;
					RETURN(FRA);
					END
				   ELSE SYMB←TEMP;
				END;
			END "C";
		END "LOOP";
	END "A";

! symbol table: killtree,killvar,reset;

	! removes from $YMTAB all nodes in the subtrees rooted at el;

RECURSIVE PROCEDURE KILLTREE (RPTR(SYMBOL) EL);
	BEGIN
	RPTR(FRAME)TEMP;
	TEMP←SYMBOL:OBJECT[EL];
	DELSYM(EL);				! removes el from $YMTAB;
	TEMP←FRAME:SON[TEMP];
	WHILE TEMP≠NULL_RECORD DO
		BEGIN
		EL←CHECK(FRAME:PNAME[TEMP],#FR);
		KILLTREE(EL);
		TEMP←FRAME:EBRO[TEMP];
		END;
	END;

	! removes the symbol from $YMTAB;

INTERNAL PROCEDURE KILLVAR(REFERENCE STRING VAR;BOOLEAN QUIET(FALSE));
	BEGIN
	RPTR (SYMBOL) EL;RPTR(FRAME)D;INTEGER OBTYPE;
	IF ¬QUIET THEN EL←OLDSYM(VAR,OBTYPE)
	ELSE EL←CHECKTOT(VAR);

	IF EL≠NULL_RECORD THEN
	IF (SYMBOL:INDEX[EL]≤OFFSET[CON_OFFSET,OBTYPE←SYMBOL:TYPE[EL]])
		AND (SYMBOL:OFFSET[EL]<'404
		AND #SC≤OBTYPE≤#FR OR OBTYPE=#MC)
	   THEN PRINT("I cannot delete ",VAR,CRLF)
	   ELSE BEGIN "DEL"
		IF OBTYPE≠#FR 
		   THEN	DELSYM(EL)
		   ELSE BEGIN
			RPTR(FRAME)TEMP;
			TEMP←SYMBOL:OBJECT[EL];
			UNLINK(TEMP);		! unfixes the frame;
			KILLTREE(EL);     		! deletes subtrees rooted in var;
			END;
		$DISPLAYLIST[OBTYPE]←NULL;
		END "DEL";
	END;

	! the procedure deletes all the variables defined by the user. It's
	  called by DELETE with no arguments.;

INTERNAL PROCEDURE RESET;
	BEGIN
	INTEGER IND,TEMP;
	FOR IND←#MIN STEP 1 UNTIL #MAX DO
	    BEGIN INTEGER K,I;
	    WHILE (TEMP←OFFSET[RES_OFFSET,IND])<(K←$ENTRY[IND]) DO
		KILLVAR(SYMBOL:PNAME[$YMTAB[IND,K]]);
	    $DISPLAYLIST[IND]←NULL;
	    END;
	END;
! assignment instruction;

	! assigns to first the value of ob2. If first has not been declared
	  the procedure determines the type of first, according to the value
	  of obtype;

INTERNAL BOOLEAN PROCEDURE PRDECL(RPTR(SYMBOL) OB1);
	RETURN((SYMBOL:OFFSET[OB1]<'400) OR
		(OFFSET[PRG_OFFSET,SYMBOL:TYPE[OB1]]
	<SYMBOL:INDEX[OB1]≤OFFSET[CON_OFFSET,SYMBOL:TYPE[OB1]]));


PROCEDURE ASGEX2(STRING FIRST; RPTR(EXPR$)EEE(NULL_RECORD);
			RPTR(SYMBOL)OB1(NULL_RECORD));
	BEGIN RPTR(EXPR$)E1; INTEGER TY;
	IF EEE THEN E1←EEE ELSE E1←$$GTEXPR;
	IF OB1=NULL_RECORD
	    THEN OB1←INSERT(FIRST,TY←EXPR$:TYPE[E1])
	    ELSE BEGIN
		IF (TY←SYMBOL:TYPE[OB1])=#FR AND EXPR$:TYPE[E1]=#TR THEN
			EXPR$:TYPE[E1]←#FR
		   ELSE IF TY=#TR AND EXPR$:TYPE[E1]=#FR
			THEN CNVRTR(OB1,FIRST)
		   ELSE IF EXPR$:TYPE[E1]≠TY THEN ERROR("INCOMAPTABILE TYPE ASSIGNMENT");
		END;
	$$PCODE←$ASGPCODE(E1,OB1);
	END;

PROCEDURE ASGEX3(RPTR(EXPR$)E);
	$$PCODE←$AASGPCODE(E,$$GTEXPR);
! tree operations:   afx_node,ufx_node,copycode,copy,copy_tree;

	! affixes the frame pointed by n to the frame pointed by d, as indicated
	  by how;
INTERNAL PROCEDURE AFX_NODE(RPTR(FRAME)N,D;INTEGER HOW);
	BEGIN
	LINKFR(N,D);				! sets links in frame tree;
	FRAME:HOWLINKED[N]←HOW;
	END;

INTERNAL PROCEDURE UFX_NODE(RPTR(FRAME)EL1,EL2);
	BEGIN
	UNLINK(EL1);				! breaks links in tree;
	FRAME:HOWLINKED[EL1]←#INDLK;
	LINKFR(EL1,F_WRLD);			! sets new links;
	END;

RECURSIVE STRING PROCEDURE COPY_TREE(RPTR(FRAME) ND; STRING PREFIX;
		REFERENCE STRING NEWNAME);
	BEGIN
	! copies the structure rooted at ND ;
 	RPTR(FRAME)KIDS;
	STRING RETSTR;
	STRING OLDNAME,LEAVE,ONAME;
	ONAME←OLDNAME←FRAME:PNAME[ND];
	! constructs the new name of the frame: if the name of the copied
	  frame contains an underscore, the part before it is substituted
	  by prefix, otherwise prefix is prefixed;
	LEAVE←SCAN(OLDNAME,$DSHTAB,$BRCHR);	
	IF $BRCHR≠0 
 	   THEN NEWNAME←PREFIX&OLDNAME
	   ELSE NEWNAME←PREFIX&LEAVE;
	FR_INSERT(NEWNAME);			! inserts a new frame;
 	KIDS←FRAME:SON[ND];
	RETSTR←NEWNAME&"←"&ONAME&";";
	WHILE KIDS≠NULL_RECORD DO
		BEGIN
		STRING NEWKID;
		RETSTR←RETSTR©_TREE(KIDS,PREFIX,NEWKID);
		RETSTR←RETSTR&" AFFIX "&NEWKID&" TO "&NEWNAME;
		IF FRAME:HOWLINKED[KIDS]≠#RGDLK THEN
			RETSTR←RETSTR&" NONRIGIDLY";
		RETSTR←RETSTR&";";
		KIDS←FRAME:EBRO[KIDS];
		END;
	RETURN(RETSTR);
	END;

	! copies the subtree rooted at startfr and affixes it to finalfr.
	  Prefix is used to build the names of the new frames;
STRING PROCEDURE PCOPY(RPTR(FRAME) STARTFR,FINALFR; STRING PREFIX);
	BEGIN
	STRING S,NEWROOT;
	S←COPY_TREE(STARTFR,PREFIX,NEWROOT);
	RETURN(S&"AFFIX "&NEWROOT&" TO "&FRAME:PNAME[FINALFR]&
		" AT "&FRAME:PNAME[STARTFR]&";");
	END;

	! merges the subtrees under startfr as sons of finalfr. Prefix is
	  used to build the names of new frames;

STRING PROCEDURE PMERGE(RPTR(FRAME) STARTFR,FINALFR;STRING PREFIX);
	BEGIN
	STRING S,NEWROOT;
	RPTR(FRAME)TEMP,BROTHER;
	TEMP←FRAME:SON[STARTFR];
	S←NULL;
	DO	BEGIN
		BROTHER←FRAME:EBRO[TEMP];
		S←S©_TREE(TEMP,PREFIX,NEWROOT);		! copies one subtree;
		S←S&"AFFIX "&NEWROOT&" TO "&FRAME:PNAME[FINALFR]&" AT "&
			FRAME:PNAME[STARTFR]&"→"&FRAME:PNAME[TEMP]&";";
		TEMP←BROTHER;
		END
	UNTIL TEMP=NULL_RECORD;
	RETURN(S);
	END;

	! executes copy or merge operation on frame1 and frame2. Name indicates
	  the required operation(copy/merge);

INTERNAL PROCEDURE COPYCODE(STRING NAME,FRAME1,FRAME2);
	BEGIN
	RPTR(FRAME) FR1,FR2;STRING PREFIX,ANSWER;
	FR1←BELONGS (FRAME1,#FR);			! frame1 must be a frame;
	FR2←BELONGS (FRAME2,#FR);			! frame2 must be a frame;
	! chooses the prefix for the new names: if the name of frame2 contains an
	  underscore takes  the part before it, otherwise takes the first three
	  characters (long names) or all the name and asks for a confirmation;
	ANSWER←FRAME:PNAME[FR2];	
	PREFIX←SCAN(ANSWER,$DSHTAB,$BRCHR);
	IF $BRCHR=0 AND
	   LENGTH(PREFIX)>5 THEN
	   PREFIX←FRAME:PNAME[FR2] [1 FOR 3];
	PRINT("it's OK to prefix to the new names ");
	PREFIX←RECOVER(PREFIX)&"_";
	$ALLOW←$ALLOW+1; ! the matching $ALLOW←$ALLOW-1 is taken care of by ASKUSER;
	IF EQU(NAME,"COPY")
	   THEN ASKUSER(PCOPY(FR1,FR2,PREFIX)&"UPDATE;")
	   ELSE ASKUSER(PMERGE(FR1,FR2,PREFIX)&"UPDATE;");
	END;
! arm interactions:  read_pos,readarm,frasg,arm_check;

	! assigns the value of pos(pointer or arm) to the frame fra. If direct
	  is indicated uses it to set the rotation part;

	! returns the pointer to the input device pos (arm or pointer);

RPTR (FRAME) PROCEDURE INPT_DEV(REFERENCE STRING POS);
	BEGIN
	RPTR(FRAME) FROM;
	IF EQU(POS,"BARM")
	   THEN RETURN(F_BARM)
	   ELSE IF EQU(POS,"YARM")
		   THEN RETURN(F_YARM)
		   ELSE BEGIN
			FROM←BELONGS(POS,#FR);
			WHILE FROM≠F_BARM AND FROM≠F_YARM
			   DO	BEGIN
			        PRINT ($SEMSG[12]);
				POS←RECOVER(POS);
				FROM←BELONGS (POS,#FR);
				END;
			RETURN(FROM);
			END;
	END;

	! reads the position of the arm from, or of the arm with pointer;

PROCEDURE READ_DEV(RPTR(FRAME) FROM);
	print("dummy call to get value of the frame");

	! reads the position of the device pos (arm or pointer);

PROCEDURE INPT(REFERENCE STRING POS);
	BEGIN
	RPTR(FRAME)FROM;
	FROM←INPT_DEV(POS);
	READ_DEV(FROM);
	END;


	! returns the pointer to the arm affixed to obj;
INTERNAL RPTR(FRAME) PROCEDURE ARM_CHECK(RPTR(FRAME) OBJ);
	BEGIN
	RPTR(FRAME) TEMP;
	TEMP←OBJ;
	WHILE TEMP≠F_WRLD DO
		IF EQU(FRAME:PNAME[TEMP],"BARM")
		   OR EQU(FRAME:PNAME[TEMP],"YARM") THEN RETURN(TEMP)
			ELSE TEMP←FRAME:DAD[TEMP];
	ABORT1(FRAME:PNAME[OBJ],$SEMSG[8]);
	END;
! arm interactions:  fconstructproc;

	! reads an axis name and returns its number:
	  xhat=0,yhat=1,zhat=2;

INTEGER PROCEDURE INPT_AXIS(REFERENCE STRING AXIS);
	BEGIN
	LABEL LL;
LL:	AXIS←RECOVER(AXIS);
	IF EQU(AXIS[2 TO ∞],"HAT") THEN RETURN(AXIS - "X")
		   ELSE BEGIN
			PRINT($SYNMSG[17],$SYNMSG[25],CRLF,"Try again ");
			GOTO LL;
			END;
	END;
	
IFC FALSE THENC
RPTR(TRANS) ARRAY T_CSTR[1:3]; 
		! used by CONSTRUCT instruction;

	! performs a construct instruction, without arguments;

PROCEDURE FCONSTRUCTPROC;
	BEGIN
	RPTR(FRAME) ELF;RPTR(TRANS)XFE;INTEGER I;
	RPTR(FRAME) FROM;STRING POS,ANSWER,FIRST;
	RPTR(VECTOR) V1,V2,V3;
	PRELOAD_WITH 
	    	"move arm to the origin of the frame"&CRLF,
		"move arm to the axis ",
		"move arm to the plane ";
		OWN STRING ARRAY INFORM[1:3];
	STRING AXIS;INTEGER F_AXIS,S_AXIS;

	$ALLOW←$ALLOW+1;
	GTOKEN;
	IF #TOKEN≠UNDECLARED_TYPE THEN ERROR("Need undeclared token for FCONSTRUCT")
		ELSE FIRST←TOKEN;

	AXIS←NULL;
	IF F_POINTER=NULL_RECORD
	   THEN PRINT("pointer is not defined cannot be used",CRLF)
	   ELSE POS←"POINTER";
	PRINT("three positions are required",CRLF);
	FOR I←1 STEP 1 UNTIL 3 DO
		BEGIN
	! determination of the input device required;
	   	PRINT("position ",I," read on ");
		POS←RECOVER(POS);
		FROM←INPT_DEV(POS);			! checks the input device;
	! determination of the positions for reading;
		PRINT(INFORM[I]);
		IF I=2
		   THEN F_AXIS←INPT_AXIS(AXIS)
		ELSE IF I=3
		   THEN BEGIN
			PRINT(AXIS," - ");
			AXIS←NULL;
			S_AXIS←INPT_AXIS(AXIS);
			IF S_AXIS=F_AXIS THEN ABORT1($SEMSG[13]);
			END;
	! reading of the arm position;
		PRINT("type <cr> when the arm is at the desired position");
		ANSWER←INCHRW;
		IF ANSWER=CR 
		   THEN ANSWER←INCHRW
		   ELSE	ABORT1($SEMSG[13]);
	 	READ_DEV(FROM);				! raads the appropriate arm pos.;
		T_CSTR[I]←ABSLOC(FROM);
		END;

	! extraction of translation part;
	V1←TPOS(T_CSTR[1]);
	V2←TPOS(T_CSTR[2]);
	V3←TPOS(T_CSTR[3]);
	
	XFE←VVVTR(V1,V2,V3,F_AXIS,S_AXIS);
	ELF←FR_INSERT(FIRST);			! inserts the new frame;
	ABSSET(ELF,XFE);			! sets the new value;
	$ALLOW←$ALLOW-1;
	IFC #DISPL THENC UPDATE;ENDC	
	END;
ENDC
! system facilities: editcode,renmcode,bailcode,qbailcode;
IFC NOT #NOFUNCT THENC
PROCEDURE UNRAVEL_SYMBOLS_USED(RPTR(expr)SYMBOLSUSED;RPTR(SYMBOL)EL);
	BEGIN RPTR(SYMBOL)EL2;
	RPTR(expr)SY,SY2; INTEGER NARGS; NARGS←0;
	SY←SYMBOLSUSED;
	WHILE SY≠NULL_RECORD DO BEGIN NARGS←NARGS+1; SY←EXPR:NEXT[SY]; END;
	IF NARGS>0 THEN
		BEGIN RPTR(EXPR)ARRAY SS[1:NARGS]; INTEGER I;
		SY←SYMBOLSUSED;
		FOR I←1 STEP 1 UNTIL NARGS DO
			BEGIN
			INTEGER J,JJ;
			SS[I]←SY;
			EL2←EXPR:PTR[SY];
			ADDSYMUSED(EL,EL2);
			SY←EXPR:NEXT[SY2←SY];
			EXPR:NEXT[SY2]←NULL_RECORD;
			END;
		MEMORY[LOCATION(SYMBOL:USES[EL])]←MEMORY[LOCATION(SS)];
		MEMORY[LOCATION(ss)]←0;
		SYMBOL:NUSES[EL]←NARGS;
		END;
	END;
ENDC
	! edits values of the variable var;
INTERNAL PROCEDURE EDITCODE (STRING VAR);
	BEGIN
	RPTR(SYMBOL)EL;INTEGER OBTYPE;STRING FBODY;
	RPTR(SCALAR,VECTOR,TRANS,FRAME,ROT,MACRO) TEMP;

	NOEXPAND ← TRUE;

	EL←OLDSYM(VAR,OBTYPE);				! var must exist in $YMTAB;
	TEMP←SYMBOL:OBJECT[EL];

	IF OBTYPE = #MC
	   THEN BEGIN
		INTEGER BRCHAR;
		STRING OLD_STRING,NEW_STRING,LINE_STRING;
		OLD_STRING← "DEFINE "&MACRO:HEAD[SYMBOL:OBJECT[EL]]
			&" = "&CVSYM(EL,EDIT_D)&";";
		NEW_STRING←LINE_STRING←NULL;
		WHILE OLD_STRING DO
			BEGIN LINE_STRING←SCAN(OLD_STRING,$CRTAB,BRCHAR);
			LODED(LINE_STRING&CR);
			NEW_STRING←NEW_STRING&INCHWL&CRLF;
			END;
		ASKUSER(NEW_STRING);
		DELSYM(EL);
		END
	ELSE  BEGIN
	SETFORMAT(0,7);	
	IF PRDECL(EL) THEN ABORT1(VAR,$SEMSG[14]);
	   IF OBTYPE=#FR AND FRAME:HOWLINKED[TEMP]≠#INDLK
	      THEN PRINT("values of ",VAR," are relative to ",
		FRAME:PNAME[FRAME:DAD[TEMP]],CRLF);
!		ELSE IF OBTYPE=#FN THEN VAR←FUNCTION:HEAD[TEMP];
	   PRINT("value of ",VAR," = ");
	IF OBTYPE=#PR THEN ERROR("Cant edit procedures yet");
	LODED(CVSYM(EL,EDIT_D)&CR);
	ASKUSER;
IFC NOT #NOFUNCT THENC
	   IF OBTYPE=#FN THEN α RPTR(EXPR)SYMBOLSUSED;
				TEMP1←FNEXPR(TEMP,FBODY,SYMBOLSUSED);
				BEGIN RPTR(EXPR) T;
					T←NEW_RECORD(EXPR);
					EXPR:PTR[T]←TREE:DATA[TEMP1];
					EXPR:TYPE[T]←TREE:DTYPE[TEMP1];
					FUNCTION:EXPR[TEMP]←T;
				END;
			DELSYMREF(EL);
			UNRAVEL_SYMBOLS_USED(SYMBOLSUSED,EL);
			 FUNCTION:BODY[TEMP]←FBODY; β
		ELSE ENDC ASGEX2(VAR);
	SETFORMAT(0,3);
	END;

	NOEXPAND ← FALSE;

	END;


	! allows renaming a variable;
INTERNAL PROCEDURE RENMCODE(STRING VAR);
	BEGIN
	RPTR(SYMBOL)OLDEL;INTEGER OBTYPE;STRING NEW;
	STRING SFSF;

	NOEXPAND ← TRUE;

	SFSF ← VAR;
 	OLDEL←OLDSYM(VAR,OBTYPE);		! var must exist in $YMTAB;
	PRINT("new name = ");
	NEW←RECOVER(VAR);			! reads the new name;
	IF NEW NEQ SFSF
	       THEN NEW←NEWSYM(NEW);			! checks new doesn't exist;
	IFC #OUTPT THENC IF $OUT THEN CPRINT($TTYCH,NEW,CRLF);ENDC
	SYMBOL:PNAME[OLDEL]←NEW;		! changes the name in record symbol;
	IF OBTYPE=#FR 
	   THEN  FRAME:PNAME[SYMBOL:OBJECT[OLDEL]]←NEW;
	$DISPLAYLIST[OBTYPE]←NULL;

	NOEXPAND ← FALSE;

	END;
IFC #DEBUG THENC
INTERNAL PROCEDURE BAILCODE;
		BEGIN
		GTOKEN(FALSE);
		IF TOKEN="("
		  THEN BEGIN
			INTEGER BRCHAR, COUNT;
			COUNT←1;
			DO BEGIN
			IF (BRCHAR←READTILL("()"))="(" THEN COUNT←COUNT+1
				ELSE COUNT←COUNT-1;
			!!QUERY←!!QUERY&TOKEN&BRCHAR;
			END UNTIL COUNT=0;
			!!QUERY←!!QUERY[1 TO ∞-1];
			END
		  ELSE STOKEN←TRUE;
		BRK_N;
		BAIL;
		END;

INTERNAL PROCEDURE QBAILCODE;
    begin integer chn, count, brchar, eof, all;
    open(chn ← getchan, "DSK", 1, 2, 0, count, brchar, eof);
    if ¬eof then
	begin
	lookup(chn, "QUERY.TXT", eof);
	count ← 1000;  setbreak(all ← getbreak, ff, null, "IS");
	if ¬eof then __query ← input(chn, all);
	end;
    outstr("!!query ← """ & __query & """" & crlf);
    release(chn); relbreak(all);
    bail;
    end;

INTEGER !!i1,!!i2,!!i3,!!i4,!!i5,!!i6;
RANY	!!r1,!!r2,!!r3,!!r4,!!r5,!!r6;

PROCEDURE DINIT;
	BEGIN !!i1←!!i2←!!i3←!!i4←!!i5←!!i6←0;
	!!r1←!!r2←!!r3←!!r4←!!r5←!!r6←null_record;
	END;

REQUIRE DINIT INITIALIZATION;

ELSEC
INTERNAL PROCEDURE BAILCODE;
	NOTAVAILCALL;

INTERNAL PROCEDURE QBAILCODE;
	NOTAVAILCALL;
ENDC
! parse procedures: other;

INTERNAL PROCEDURE DEFLT(STRING HOW);
	BEGIN
	IF EQU(OLDCMD,"OPEN") OR EQU(OLDCMD,"CLOSE")
	   THEN OPENING(OLDCMD,OLDOBJ,HOW)
	ELSE IF EQU(OLDCMD,"MOVEX")OR EQU(OLDCMD,"MOVEY")OR EQU(OLDCMD,"MOVEZ")
		THEN IF HOW="BY"
			THEN ALONGPROC(OLDCMD[5 FOR 1],OLDOBJ)
			ELSE ERROR($SYNMSG[10],$SYNMSG[25])
	ELSE IF EQU(OLDCMD,"DRIVE")
		THEN JTMOVE("BJT",HOW,CVD(OLDOBJ))
	ELSE IF EQU(OLDCMD,"MOVE") 
		THEN IF EQU(HOW,"BY") THEN PBYPROC ELSE PTOPROC;
	END;

PROCEDURE ASGMNT(STRING FIRST;RPTR(SYMBOL)S);
	IF (S≠NULL_RECORD) AND PRDECL(S) THEN
		ERROR("You cannot change the value of "&FIRST)
		ELSE ASGEX2(FIRST,NULL_RECORD,S);
	
INTERNAL PROCEDURE OTHER;
	BEGIN STRING FIRST; RPTR(SYMBOL)SS; RPTR(EXPR$)EE;
	$HELP←41; FIRST←TOKEN;  EE←NULL_RECORD;
 	IF (SS←TOKENPTR)≠NULL_RECORD THEN
		BEGIN IF SYMBOL:ACCESS[TOKENPTR]=#ARRAY
			THEN EE←AREF(TOKENPTR,XCHNGE)
			ELSE IF SYMBOL:ACCESS[TOKENPTR]=#PROCEDURE
				THEN BEGIN $$PCODE←PREF(TOKENPTR);
				RETURN; END;
		END;
	GTOKEN;
	IF TOKEN="←"
	   THEN IF EE THEN ASGEX3(EE) ELSE ASGMNT(FIRST,SS)
	   ELSE ERROR($SYNMSG[32],NULL);
	END;

! main program;


WHILE TRUE DO
	BEGIN 
	$COMPILE←0;		! set interpreter mode;
	$LEVEL←0;		! indicate it is top level ;
	$TMPOFF←$SYMOFF;
	CURPROC←NULL_RECORD;
	CURBLOCK←NULL_RECORD;
	STBEGIN←TRUE;			! waiting for a new command;
	$CLNSAVE←NULL;			! get rid of the saved string;
	PARSE;				! parses the instruction;
	CHKESC_I;
MAINL: STOKEN←FALSE;
	IFC #WRIST THENC IF WSTPTR THEN RWRIST("READ");	ENDC
	IF !LINE THEN PRINT(CRLF,"LAST STATEMENT: ",$CLNSAVE);
	END;